CD Actual 1/PC Actual CD 01.iso/trucos/pascal/pascal.wri

Text File | 1995-02-10 | 38.4 KB | 2,292 lines

PASCAL

GRABAR Y RECUPERAR PANTALLAS DE TEXTO

Programando en Turbo Pascal, hay ocasiones en las que se necesita
½salvar╗ la pantalla con la que estamos trabajando, y restaurarla
despuΘs de hacer algo (mostrar un peque±o men· de ayuda, hacer una
pregunta, etc). Esta es la utilidad de estas dos rutinas, la primera
de ellas, llamado ½Savescreen╗, se encarga de guardar la memoria de
video directamente en un archivo. Su formato es el siguiente:

Savescreen(Nombre);

donde ½Nombre╗ es el nombre del archivo con el que se guardarß la
pantalla.

El segundo procedimiento se encarga de 'restaurar' la pantalla. Su
formato es el siguiente:

Restscreen(Nombre);

donde ½Nombre╗ es el nombre del archivo a restaurar.

Estos procedimientos estßn probados, y funcionan para pantallas del tipo
80 x 25, 16 Colores, es decir para pantallas de texto. El tama±o que se
graba es de 4000 bytes, porque la pantalla es de 80 columnas x 25 filas
= 2000 bytes, pero como cada caracter lleva asociado un atributo, esto
hace un total de 2000 x 2 = 4000 bytes.


procedure savescreen(__name:string);

var

 f :file;

 p :pointer;

begin

 assign(f,__name);

 rewrite(f);

 { abre el fichero. si existe, lo destruye. }

 close(f);

 { cierra el fichero. }

 reset(f,1);

 { abre el fichero otra vez. }

 p:=ptr($b800,$0000);

 { el puntero p^ apunta a la direcci≤n $b800:0000 }

 blockwrite(f,p^,4000);

 { guarda la pantalla }

 close(f);

end;


procedure restscreen(__name:string);

var

 f :file;

 p :pointer;

begin

 {$i-}

 assign(f,__name);

 reset(f);

 { comprueba si exite el fichero especificado. }

 close(f);

 {$i+}

 if ioresult=0 then begin

 assign(f,__name);

 reset(f,1);

 p:=ptr($b800,$0000);

 { el puntero p^ apunta a la direcci≤n $b800:0000 }

 blockread(f,p^,4000);

 { lee los datos y los pone en pantalla }

 close(f);

 end;

end;

Daniel Sßnchez Teodoro

Granada



NUMEROS CON PUNTOS

Estas dos funciones escritas en Pascal permiten la escritura de un
n·mero con los puntos de separaci≤n de millares. Este tipo de
funciones tienen gran utilidad en aplicaciones (por ejemplo de
contabilidad) en las que se deseen presentar resultados de cantidades
con cierta calidad.

La primera (UsingLong) sirve para n·meros ½LongInt╗ y la segunda
(Usingreal) para n·meros reales y hace uso de la anterior.

Function UsingLong (n:LongInt):string;

Const

 Punto='.';

Var

 f,Largo : byte;

 s : String;

 Signo : String[1];

Begin

 If n<0 Then Signo := '-'

 Else

 Signo := '';

 n:=Abs(n);

 Str(n,s);

 For f := 1 to 3 do

 If Length(s) >= 4*f Then

 Insert (Punto,s,Length(s)-f*4+2);

 UsingLong:=Signo+s;

End;

Function UsingReal(r:Real; deci:byte): String;

Var

 m : Real;

 n : LongInt;

 s,t : String;

Begin

 n := Trunc(r);

 s := UsingLong(n);

 m := Frac(r);

 m := Abs(m);

 If deci >0 Then

 Begin

 Str (m:deci+2:deci,t);

 t := Copy (t,2,length(t)-1);

 s := s+t;

 End;

 UsingReal := s;

End;


JosΘ M. Serrano

LΘrida



CAMBIAR LA TABLA DE CARACTERES

El procedimiento ½xchr╗ permite transformar un carßcter en cualquier
otro que nosotros dise±emos. Para ello nos crearemos una tabla de 8
columnas por 16 filas como la del ejemplo y calcularemos los valores
teniendo en cuenta que para cada una de las columnas de una fila son
128, 64, 32, 16, 8, 4, 2 y 1. Para cada fila sumamos los valores
correspondientes a las columnas que tachemos para crear el carßcter.
Un ejemplo:

 ........ 00

 ........ 00

 ..****.. 60

 ..****.. 60

 ..*..... 32

 ..**.... 48

 ...**... 24

 ....**.. 12

 ........ 00

 ..****.. 60

 ..****.. 60

 ........ 00

 ...**... 24

 ...**... 24

 ........ 00

 ........ 00

Una vez que hemos calculado los bytes correspondientes a las 16 filas
(las cifras representadas a la derecha), los colocamos en un
array de la siguiente forma:

MIO :array [0..15] of BYTE= (00, 00, 60, 60, 32, 48, 24, 12, 00, 60,
60, 00, 24, 24, 0, 0 );

Con todos estos datos podemos generar el siguiente programa para
cambiar el juego de caracteres.

uses dos;

type font16 = array [ 0..15] of byte;

const

 ONDAS :font16 =

 ($94, $84, $48, $30, $00, $C1, $22, $14, $94, $84, $48, $30, $00, $C1,
 $22, $14);

 MIO :font16=

 (00, 00, 60, 60, 32, 48, 24, 12, 00, 60, 60, 00, 24, 24, 0, 0);

procedure xchr(CH:CHAR ;VAR s);

var regs:registers;

{ La variable s no tiene tipo declarado para que usemos bien matrices
 de 16 bytes o de 8 seg·n el tipo de fuente actual }

begin

regs.dx:=ord(ch);

with regs do

begin

 ah:=$11;

 al:=$00;

 bh:=16;

 bl:=8;

 cx:=1;

 es:=seg (S);

 bp:=ofs (S);

end;

intr ($10,regs);

{ S≤lo es soportada por EGA, MCGA y VGA (y no CGA o MDA) }

end;

begin

 xchr ('A',ondas);

 writeln ('AAAA');

end.


Nota del L.T.: Este programa s≤lo cambia el c≤digo de un carßcter,
pero no es difφcil (aunque sφ laborioso) cambiar totalmente el juego
de caracteres. Simplemente deberemos generar un array para cada uno
de los 255 caracteres. Una buena idea es ponerlo todo de forma que
cargue la tabla de caracteres desde un bucle, para automatizar el
proceso.

Alberto Vallejo Martφnez

Burgos


DIRECTORIOS ½DIRECTOS╗

A pesar de que el Borland Pascal incluye una orden para crear
directorios (½MKDir╗), esta rutina incorpora la interesante novedad de
que permite crear m·ltiples directorios a la vez, unos dentro de
otros, sin tener que crearlos uno por uno.

A este procedimiento se le pasa un ½string╗ con el directorio completo
(podemos a±adir al resultado de ½getdir╗ el directorio a crear), y dos
variables booleanas que indican si el directorio es imposible de crear
por ser incorrecto sintßcticamente, unidad inexistente o bien si ya
existφa. Hay que advertir que dichas variables deben estar
inicializadas a ½false╗.

PROCEDURE Creardir (dir:String; VAR error, existe:BOOLEAN);

VAR dir2:String;

 ind,io:Integer;

 faux:File;

BEGIN

 {$i-}

 ind:=Length(dir);

 dir2:=dir;

 IF (ind<>0) AND (dir[ind]<>':') THEN

 BEGIN

 WHILE (dir2[Length(dir2)] <>'\') AND (Length(dir2)<>0) DO

 Delete(dir2,Length(dir2),1);

 Delete(dir2,Length(dir2),1);

 IF Length(dir2)>0 THEN Creardir(dir2,error,existe)

 ELSE error:=true

 END

 ELSE IF ind=0 THEN error:=true

 ELSE BEGIN

 Assign(faux,dir+'\prueba.dat');

 Rewrite(faux);

 IF ioresult=0 THEN BEGIN

 Close(faux);

 Erase(faux)

 END

 ELSE error:=true

 END;

 IF not(error) THEN error:=ind=0;

 IF (ind<>0) AND (dir[ind]<>':') AND NOT (error) THEN

 BEGIN

 IF NOT error THEN mkdir(dir);

 io:=ioresult;

 IF existe THEN existe:= io=5;

 IF NOT (error) THEN error:= (io<>0) AND (io<>5)

 END;

END;

Julio Maiques Pena

Valencia



BITES SIGNIFICATIVOS

En Pascal no hay ninguna funci≤n estßndar que nos traduzca los bites
significativos de un valor de tipo binario, algo de gran utilidad si
nos interesa, por ejemplo, manejar los atributos de un fichero. Con
una funci≤n en ensamblador, sin embargo, resolvemos el problema en tan
solo unas cuantas lφneas. La funci≤n es como sigue:

Function BiteActivo(BiteBuscado, Lugar:Word):boolean;assembler;

asm

mov ax, BiteBuscado

and ax, Lugar

cmp ax,0 {si es 0, no se haya activo}

je @1 {false =0}

mov ax,1 {true=1}

@1:

end;

Fco. Javier Delgado Martφnez

Madrid


SONIDO POR INTERRUPCIONES

Este es un truco residente que hace sonar el teclado de forma curiosa.
Con las teclas ½+╗, ½-╗, y con los n·meros 1 al 9, se puede variar el
tono y duraci≤n del sonido respectivamente. S≤lo suena cuando se
pulsa alguna tecla, para ello el programa mira directamente la tecla
pulsada en el buffer.

program sonido;

{$M 1024,0,0}

uses crt,dos;

 var progr:procedure;

 regs:registers;

 ofs,entrada:word;

 mul,mul2:integer;

{$F+}

 procedure rutina;interrupt;

 var b,d:integer;

begin

 entrada:=memw[$40:$1c];

 if entrada<>30 then

 begin

 entrada:=entrada-2; { letra -2 bytes es tu letra }

 end

 else entrada:=60;

 ofs:=memw[$40:entrada];

 b:=lo(ofs); { n·mero de letra }

 if b=43 then mul:=mul+1;

 if b=45 then mul:=mul-1 ;

 if (b>=49) and (b<=57) then mul2:=b-48;

 mul:=abs(mul);

 for d:=b*100 downto 0 do sound((d*mul div 2)+b);

 nosound;

 progr;

end;

 {$F-}

begin

 mul:=1;

 mul2:=1;

writeln(' SONIDO v1.00 ');

getintvec($9,@progr);

setintvec ($9,addr(rutina));

keep(0);

end.

Jorge Juan ArestΘ Espi

Muro (Alicante)


RUTINAS PARA EL TECLADO

Las siguientes rutinas proporcionan un mayor control sobre el teclado.
La primera de ellas, AceleraTeclado, sirve (como su propio nombre
parece indicar) para acelerar considerablemente la respuesta del
teclado. Su utilizaci≤n es bien sencilla, y puede ser de gran
utilidad para determinados juegos que requieran una rßpida respuesta.
Las otras dos, MaskOutKbd y UnMaskKbd tienen como funci≤n la de
activar y desactivar el teclado.

Procedure AceleraTeclado;

assembler; asm

 mov ax,$305

 xor bx,bx

 int 16h

end;

Procedure MaskOutKbd; Assembler;

asm

 in al,21

 or al,00000010b

 out 21h,al

end;

Procedure UnMaskKbd; Assembler;

asm

 in al,21

 or al,11111101b

 out 21h,al

end;

La siguiente funci≤n lee una tecla del teclado o bien del buffer del
teclado, y devuelve una variable numΘrica de formato Word, de modo que
en el byte mßs alto obtenemos el c≤digo de rastreo y en el byte mßs
bajo el c≤digo ASCII. Para obtener ambos valores podemos emplear las
funciones Hi y Lo, para obtener los bytes mßs significativos y menos
significativos respectivamente.

El uso de ambos valores combinados es interesante pues podemos
distinguir la pulsaci≤n de las flechas del cursor, del teclado
numΘrico, la pulsaci≤n de ½Alt╗ o ½Ctrl╗ con otra tecla, etc. TambiΘn
es interesante el uso del byte de rastreo, pues este dato no
diferencia, dada una tecla en particular, si se ha pulsado may·scula o
min·scula o en combinaci≤n con ½Ctrl╗ o ½Alt╗. En resumen, cada tecla
tiene un c≤digo de rastreo asignado. La lista de todos los c≤digos
obtenidos al pulsar cada tecla es demasiado extensa para incluirla
aquφ, pero todo es cuesti≤n de ir probando. Por ejemplo, el c≤digo de
rastreo para la letra ½A╗ es el 30 (1E en Hexadecimal), tanto
may·scula como min·scula, aunque su c≤digo ASCII es 65 para la
may·scula y 97 si es min·scula. Si pulsamos ½Ctrl+A╗ obtenemos 3001,
y si pulsamos ½Alt+A╗ obtenemos 3000.

Function LeeTecla : Word; Assembler;

Asm

 xor ax,ax

 int $16

End;

Definiendo al principio del programa las siguientes variables:

Var

 TeclaCabeza : Word Absolute 0:$41A;

 TeclaCola : Word Absolute 0:$41C;

De esta forma, TeclaCabeza contiene el c≤digo de la tecla que se
encuentra al principio del buffer del teclado, mientras que en la
variable TeclaCola se almacena el c≤digo de la tecla que se encuentra
en la cola del buffer.

TambiΘn podemos utilizar el siguiente procedimiento, que se encarga de
limpiar el buffer de teclado de una forma rßpida y efectiva.

Procedure LimpiaBuffer;

Begin

 TeclaCabeza:= TeclaCola;

End;

Podemos comparar TeclaCabeza con TeclaCola; en caso de obtener valores
diferentes podemos afirmar que se ha pulsado una tecla. De esta forma
obtenemos una nueva y sencilla forma para la funci≤n ½KeyPressed╗. Lo
podemos hacer directamente comparando ambos valores mediante un If
TeclaCabeza<>TeclaCola Then.... O podemos emplear la siguiente
funci≤n en ensamblador que hace el mismo trabajo.

Function TeclaPulsada : Boolean; Assembler;

asm

 xor ax,ax

 mov es,ax

 mov ax,[es:TeclaCabeza]

 sub ax,[es:TeclaCola]

 jz @@1

 mov ax,1

@@1:

 sti

end;

Hemos de recordar que las funciones y procedimientos que hacen uso del
ensamblador incorporado en Turbo Pascal, s≤lo podrßn ser compiladas en
versiones posteriores a la 6.0, primera versi≤n en que se incorpor≤
esta capacidad.

Santos Herranz Domingo

Madrid



ESPACIO EN EL DISCO

Cada vez que efectuamos un ½dir╗ de un directorio del disco se nos
muestra la informaci≤n de los bytes ocupados y los que quedan libres.
Aunque esta informaci≤n es mßs que suficiente, gracias a este programa
podremos conseguir un resultado mßs vistoso de esta informaci≤n. La
funci≤n de este programa es la de crear una barra de porcentaje con la
cantidad del disco duro que tenemos ocupado.

Ademßs, no s≤lo nos muestra el tanto por ciento de disco ocupado, sino
que para mayor informaci≤n el programa nos indica los bytes totales,
los ocupados y los que nos quedan libres.

Program BarDisk;

Uses Crt, Dos;

Var total, Libre, Tanto: LongInt;

 Numero: String;

 i: Byte;

Function PuntoMil (n: LongInt): String;

Var f: Byte;

 s: String;

Begin

 Str(n,s);

 For f:=1 to 3 do

 If length (s) >= 4*f then

 Insert('.',s, Length(s) - f*4+2);

 PuntoMil:=s;

End;

Begin

 Total:=DiskSize(0) div 1024;

 Libre:=DiskFree(0) div 1024;

 Tanto:=((Total-Libre) *100) div Total;

 TextColor(3);

 GotoXY(24,WhereY);

 WriteLn(Tanto,'% de espacio en disco ocupado');

 {Dibuja barra y coloca porcentajes}

 For i:=3 To 78 do

 Begin

 GotoXY (i,WhereY);

 Write (#176);

 End;

 textColor(14);

 Tanto:= ((Total-Libre)*78) div Total;

 For i:=3 to Tanto do

 Begin

 GotoXY(i,WhereY);

 Write(#219);

 End;

 TextColor(3);

 WriteLn;

 GotoXY(3,WhereY); Write(#179,'0%');

 GotoXY(38,WhereY); Write(#179,'50%');

 GotoXY(74,WhereY); WritelN('100%',#179);

 WriteLn;

 { Coloca datos del disco }

 Numero := PuntoMil (DiskSize(0));

 WriteLn(#175#32, Numero, ' bytes totales ');

 Numero := PuntoMil (DiskSize(0)-DiskFree(0));

 WriteLn(#175#32, Numero, ' bytes ocupados');

 Numero := PuntoMil (DiskFree(0));

 WriteLn(#175#32, Numero, ' bytes libres');

 TextColor(7);

 WriteLn;

End.

Juan Antonio Fernßndez Moreno

Huelva


ZOOM GRAFICO

Este programa incluye la rutina ½deforma╗, que permitirß efectuar
ampliaciones y reducciones, y en general cualquier tipo de deformaci≤n
de una zona de la pantalla.

Para su uso s≤lo hemos de llamar a ½deforma╗ con las coordenadas x, y
de la esquina superior izquierda de la imagen a deformar; tras Θstas,
las coordenadas x, y de la esquina inferior izquierda de la imagen a
deformar. DespuΘs de teclear las cuatro coordenadas introducimos las
mismas, pero esta vez dando las coordenadas donde queremos situar la
imagen. Hay que notar que no tienen por quΘ tener el mismo tama±o, ya
que el procedimiento se encarga de deformar la imagen para adecuarla a
las coordenadas de destino.

En el programa de ejemplo podemos ver un ejemplo del uso de la rutina
para efectuar un zoom hacia afuera.

program Uso_de_Deforma;

uses Crt;

type

 pantalla = array [0..199,0..319] of byte;

var

 pantallaPTR : ^pantalla;

 z : integer;

procedure deforma(x1,y1,x2,y2,x3,y3,x4,y4 : integer);

var

 x,y,dx1,dy1,dx3,dy3 : integer;

begin

 dx1:=x2-x1;

 dy1:=y2-y1;

 dx3:=x4-x3;

 dy3:=y4-y3;

 for y:=0 to dy3 do

 for x:=0 to dx3 do

pantallaPTR^[y+y3,x+x3]:=pantallaPTR^[((y*dy1)div dy3)+y1,((x*dx1)div
dx3)+x1];

 end;

begin

 asm

 mov ax,13h

 int 10h

 end;

 pantallaPTR := ptr($a000,0); (*este puntero apunta a la pantalla*)

 for z:=0 to 100 do

 pantallaPTR^[random(29),random(29)]:=random(255);

 for z:=10 to 150 do

 begin

 deforma(0,0,29,29,100,40,100+z,40+z);

 delay(50);

 end;

end.

Antonio Ruiz

Mßlaga



INFORMACION SOBRE EL RATON

El siguiente programa, realizado en Turbo Pascal, efect·a un completo
test del rat≤n mostrando la siguiente informaci≤n: n·mero de botones,
IRQ utilizada, tama±o del buffer de estado, versi≤n del driver, idioma
utilizado y tipo de rat≤n (serie, bus, etc.). Ademßs, activa el
cursor para que lo podamos ver en pantalla.

Todas las llamadas a las distintas funciones del rat≤n se realizan a
travΘs de la interrupci≤n 33h. Como se puede comprobar, esta
interrupci≤n estß muy utilizada en este programa.

Program MTest (Mouse_Test);

Uses Crt, Dos;

Const aTipo: Array [1..5] Of string [8]=('Bus', 'Sere', 'InPort',
'PS/2', 'HP');

 aIdio: Array [0..8] Of string = ('InglΘs', 'FrancΘs', 'HolandΘs',
 'Alemßn','Sueco','FinlandΘs', 'Espa±ol','PortuguΘs','Italiano');

Var regs:Registers;

 Botones: Byte;

Begin

 Regs.AX:=0;

 INTr($33,regs);

 WriteLn;

 If regs.AX=0 Then

 Begin

 WriteLn('No se encontr≤ el driver del rat≤n.');

 Halt;

 End

 Else

 Begin

 Botones:=regs.BX;

 {Dibuja Mouse}

 TextColor(15);

 WriteLn(#186:6);

 WriteLn(#219#177#219#177#219:8);

 WriteLn(#219#219#219#219#219:8);

 WriteLn('Driver del rat≤n en memoria.');

 WriteLn;

 {Coloca datos y activa rat≤n}

 regs.AX:=$24;

 INTr($33, regs);

 WriteLn('Versi≤n del driver: ', regs.BH, '.', regs.BL);

 WriteLn('Tipo del rat≤n....: ', (aTipo[regs.CH] ));

 WriteLn('N·mero de botones.: ', botones);

 WriteLn('Instalado en IRQ..: ', regs.CL);

 regs.AX:=$23;

 INTr($33,regs);

 WriteLn('Idioma............: ', (aIdio[regs.BX]));

 regs.AX:=$15;

 INTr($33,regs);

 WriteLn('Buffer de estado..: ', regs.BX, ' bytes');

 Regs.AX:=1;

 INTr($33,regs);

 Repeat Until KeyPressed;

 regs.AX:=2;

 INTr($33,regs);

 TextColor(7);

 WriteLn;

 End;

End.

Juan Antonio Fernßndez Moreno

Huelva


VISUALIZADOR DE FICHEROS BMP

Este es un interesante programa que nos permite visualizar ficheros
BMP de 256 colores con codificaci≤n RGB. Aunque admite ficheros de
cualquier resoluci≤n, en las imßgenes mayores de 320 x 200 s≤lo se
visualizarßn las primeras 320 columnas y las primeras 200 filas; el
resto no se visualizarß.

Para su ejecuci≤n deberemos introducir ½VER_BMP nombre_fichero
[.BMP]╗. Esta rutina no comprueba la existencia de tarjeta grßfica
VGA, ni tampoco la existencia del fichero BMP introducido como
parßmetro; de manera que si se introduce un nombre no vßlido o no se
dispone de VGA se provocarß un error de ejecuci≤n.

Recordemos que s≤lo visualiza ficheros BMP con codificaci≤n RGB y con
256 colores, de manera que si una imagen no puede visualizarse serß
por cualquiera de estos tres motivos: bmpfile.bfType distinto de
CABEZA_BMP (no es un fichero BMP); bmpinfo.biBitCount distinto de 8
(no es un fichero de 256 colores), o bmpinfo.biCompression distinto de
0 (no tiene codificacion RGB).

Notas acerca de la rutina y los ficheros BMP

Dadas las diferentes caracterφsticas de VGA y BMP es necesario
reconvertir la paleta almacenada en un fichero BMP a un formato vßlido
para la VGA, ya que los valores que almacena el fichero BMP para cada
componente de color estan entre 0 y 255, mientras que la VGA s≤lo
maneja valores entre 0 y 63 para cada componente de color.

Por otra parte, la estructura de la paleta de un BMP asigna 4 bytes
para cada color, almacenando los colores en el siguiente orden: azul,
verde y rojo; mientras que la paleta que debe ser pasada a los
registros DAC de la VGA s≤lo tiene 3 bytes para cada color de la
paleta y los colores deben ir en el orden inverso, es decir, rojo,
verde y azul.

Por ·ltimo, la longitud de una lφnea de imagen almacenada en un
fichero BMP siempre es m·ltiplo de 4, por lo que una imagen con un
ancho que no sea m·ltiplo de dicha cantidad tendrß bytes basura, que
no deben ser visualizados (de hecho, tendrß tantos bytes basura como
los necesarios para igualar la longitud al m·ltiplo de 4 superior mßs
pr≤ximo).

Dado que la inicializaci≤n del modo de vφdeo se hace en ensamblador no
es necesario disponer del driver BGI correspondiente. Aunque, eso sφ,
para poder compilarlo necesitaremos al menos la versi≤n 6.0 de Turbo
Pascal.

Por otra parte, hay que se±alar que las lφneas:

cont := port[$3da]; port[$3c0] := $20;

cont := port[$3da]; port[$3c0] := $20;

posibilitan que s≤lo se muestre la imagen una vez que Θsta estΘ entera
en la pantalla. De ahφ que si queremos que la imagen vaya siendo
dibujada lφnea a lφnea, baste con eliminarlas.

Una ·ltima aclaraci≤n: las lφneas de imagen de un fichero BMP se almacenan
en orden inverso a como aparecerßn en la pantalla, esto es, la primera
lφnea de imagen en el fichero se corresponde con la ·ltima que aparece en
pantalla. Es por esto que el bucle en el que se transfiere la imagen del
archivo a la pantalla vaya de valores mayores a menores.

Program Ver_BMP;

Uses

 crt, dos;

Const

 CABEZA_BMP = $4D42;

Type

 BitmapFileHeader = Record

 bfType :word;

 bfSize :longint;

 bfReserved1,

 bfReserved2 :word;

 bfOffbits :longint;

 end;

 BitmapInfoHeader = record

 biSize, biWidth,

 biHeight :longint;

 biPlanes,

 biBitCount :word;

 biCompression,

 biSizeImage,

 biXpelsperMeter,

 biYpelsPerMeter,

 biClrUsed,

 biClrImportant :longint;

 end;

 RGBQuad = record

 rgbBlue, rgbGreen, rgbRed, rgbReserved :byte;

 end;

 rgbDAC = record

 rgbRed, rgbGreen, rgbBlue :byte;

 end;

 RGBQpaleta = array[0..255] of RGBquad;

 RGBpaleta = array[0..255] of rgbDAC;

 linea320 = array[0..319] of byte;

Var

 fichero :file;

 name :string;

 bmpFile :bitmapFileHeader;

 bmpInfo :bitmapInfoHeader;

 bmpPalet :RGBQpaleta;

 Paleta :rgbPaleta;

 linea :^linea320;

 suma :byte;

 scanline, mover, cont :word;

 regs :registers;

 buffergraf :array [0..64000] of byte absolute $a000:$00;

Begin

 name := paramstr(1);

 if pos('.',name) < 1 then

 name := name + '.bmp';

 assign(fichero, name);

 reset(fichero, 1);

 blockread(fichero, bmpfile, sizeof(bmpfile));

 blockread(fichero, bmpinfo, sizeof(bmpinfo));

 if (bmpfile.bfType <> CABEZA_BMP) or (bmpinfo.biBitCount <> 8) or

 (bmpinfo.biCompression <> 0) then

 writeln ('No se puede Visualizar el fichero')

 else begin

 blockread (fichero, bmpPalet[0], sizeof(bmpPalet));

 for cont := 0 to 255 do begin

 paleta[cont].rgbRed := bmpPalet[cont].rgbRed div 4;

 paleta[cont].rgbGreen := bmpPalet[cont].rgbGreen div 4;

 paleta[cont].rgbBlue := bmpPalet[cont].rgbBlue div 4;

 end;

 cont := bmpinfo.biWidth mod 4;

 case cont of

 1: suma := 3;

 2: suma := 2;

 3: suma := 1;

 else

 suma := 0;

 end;

 scanline := bmpinfo.biWidth + suma;

 if bmpinfo.biWidth > 320 then

 mover := 320

 else

 mover := bmpinfo.biWidth;

 asm

 mov ax, 0013h

 int 10h

 end;

 regs.ax := $1012;

 regs.bx := $00;

 regs.cx := $100;

 regs.es := seg(paleta[0]);

 regs.dx := ofs(paleta[0]);

 intr($10, regs);

 getmem(linea, scanline);

 cont := port[$3da];

 port[$3c0] := $00;

 if bmpinfo.biheight > 200 then begin

 seek(fichero, filepos(fichero)+ scanline * (bmpinfo.biheight-200));

 bmpinfo.biheight := 200

 end;

 for cont := (bmpinfo.biheight - 1) downto 0 do begin

 blockread(fichero, linea^[0], scanline);

 move (linea^[0], bufferGraf[cont*320], mover);

 end;

 cont := port[$3da];

 port[$3c0] := $20;

 close(fichero);

 freemem(linea, scanline);

 repeat until keypressed;

 asm

 mov ax, 0003h

 int 10h

 end;

 end;

end.

Carlos Soto Garcφa

Las Rozas (Madrid)


RUTINAS GRAFICAS

La introducci≤n a la programaci≤n del modo de vφdeo 13h de la VGA ha
tenido gran aceptaci≤n entre todos nuestros lectores. Buena prueba de
ello es que estamos recibiendo gran cantidad de rutinas para este modo
de vφdeo. Un buen ejemplo es la siguiente unidad para Turbo Pascal
6.0 ≤ posterior, que contiene diversas rutinas (la mayorφa en
ensamblador) de gran interΘs para el mencionado modo de 320x200x256.

La unidad contiene los siguientes procedimientos:

LeePcx: Este procedimiento descomprime un fichero en formato
grßfico PCX de 320x200x256 (con la condici≤n de que el tama±o del
fichero no exceda de 64 Kbytes) y almacena el resultado en una zona de
memoria. TambiΘn devuelve la paleta del fichero.

MueveGraf: Se encarga de escribir en pantalla un grßfico
descomprimido con el procedimiento anterior. TambiΘn sirve para mover
grßficos que sean una imagen exacta de la memoria de pantalla. Es
equivalente a la instrucci≤n ½move╗ de Turbo Pascal.

LeeSprite: Captura una regi≤n de la pantalla y la almacena en
una regi≤n de memoria especificada. El formato del grßfico es el
siguiente: en la posici≤n 0 con un tama±o de una palabra se guarda el
ancho del dibujo; en la posici≤n 2 con un tama±o de una palabra se
guarda el alto del dibujo, y a partir de la posici≤n 4 con un tama±o
de (ancho x alto) bytes se guarda el dibujo grabado por filas.

PonSprite: Devuelve a la pantalla una regi≤n capturada con el
procedimiento ½LeeSprite╗. Ademßs, permite realizar operaciones
l≤gicas entre el dibujo y lo que hay en pantalla. Para seleccionar
quΘ operaci≤n l≤gica vamos a usar existen las constantes
mskNormal, mskXor, mskOr, mskAnd y
mskNot. Estas constantes vienen dadas en la siguiente tabla
donde se indican tambiΘn sus valores numΘricos, y las operaciones
l≤gicas que se realizan entre los puntos de la pantalla y del
Sprite.

MskNormal 0 MOV

MskXOR 1 XOR

MskOR 2 OR

MskAND 3 AND

MskNOT 4 NOT

Unit Graficos;

Interface

Const

 {-- Constantes del fundido --}

 funRojo = 0;

 funAzul = 1;

 funVerde = 2;

 {-- Operaciones l≤gicas del procedimiento PonSprite --}

 mskNormal = 0;

 mskXOR = 1;

 mskOR = 2;

 mskAND = 3;

 mskNOT = 4;

Type

 TPaleta = Array[0..767] of Byte;

 Procedure LeePcx(var Graf;Total:Word;var Pal:TPaleta;var Imagen);

 Procedure MueveGraf(var Graf);

 Procedure PonSprite(X,Y:Word;Mask:Byte;var Graf);

 Procedure LeeSprite(x1,y1,x2,y2:Word;var Graf);

 Procedure PonPunto(X,Y:Word;Color:Byte);

 Procedure Escribe(X,Y:Word;Texto:String;Color:Byte);

Implementation

Var

 Seg1F,

 Ofs1F : Word;

Procedure LeePcx; Assembler;

{ Descomprime un fichero PCX en formato 320x200x256. Se asume que la

 informaci≤n que se pasa como grßfico es correcta. El fichero ha de tener

 menos de 64k. El dibujo resultante se almacena en la variable IMAGEN y la

 paleta correspondiente en PAL. }

Var

 Cont : Word;

Asm

 Push Ds

 { CONT indica d≤nde empieza la paleta }

 Mov Ax,Total

 Mov Cont,Ax

 Sub Cont,768

 { Cada valor de la paleta ha de ser dividido por 4 }

 Lds Si,Graf { Se cargan dos punteros a la variable GRAF }

 Les Di,Pal

 Add Si,Cont { Se colocan donde empieza la paleta }

 Cld

 Mov Cx,768 { Hay 256*3 elementos }

 Mov Bl,4

 Xor Dx,Dx { Para dividir no se usa DX ni AH }

 Xor Ah,Ah

@Divide:

 Lodsb

 Xor Ah,Ah

 Div Bl { Divide cada byte por 4 }

 Stosb

 Loop @Divide

 { Con Es:Di se direccionarß la memoria de vφdeo }

 Les Di,Imagen

 { Se salta la cabecera. Usa Ds:Di para leer de la variable }

 Lds Si,Graf

 Add Si,128

 Mov Dx,Cont

 { El byte alto del contador no se va a usar }

 Xor Ch,Ch

@Bucle:

 Lodsb { Carga el byte actual }

 Cmp Al,192 { Si es menor de 192 s≤lo se dibuja una vez }

 Jb @NoRepite

 Sub Al,192 { Calcula cuantas veces se ha de dibujar }

 Mov Cl,Al

 Lodsb { Lee el color que se habrß de escribir }

 Jmp @Escribe

@NoRepite:

 Mov Cx,1 { S≤lo hay que imprimir un pixel }

@Escribe:

 Stosb { Escribe el color }

 Loop @Escribe { tantas veces como haga falta }

 Cmp Si,Dx { Comprueba si hemos llegado al final }

 Jnz @Bucle

 Pop Ds { Se tiene que restaurar DS }

End; { PROCEDURE LeePcx }

Procedure MueveGraf;Assembler;

Asm

 Push Ds

 Lds Si,Graf

 Mov Ax,0A000h

 Mov Es,Ax

 Xor Di,Di

 Mov Cx,32000

 Rep Movsw

 Pop Ds

End; { PROCEDURE MueveGraf }

Procedure PonSprite;Assembler;

{ Escribe en pantalla un sprite de los creados por el procedimient LeeSprite,

 haciendo una operaci≤n l≤gica al escribirlo. }

Var

 Ancho,Alto : Word;

Asm

 Push Ds

 Dec X

 Dec Y

 Les Di,Graf { Lee el alto y ancho del grßfico }

 Mov Ax,word ptr [Es:Di]

 Mov Ancho,Ax { que se encuentran en las dos primeras palabras }

 Mov Ax,Es:[Di+2]

 Mov Alto,Ax

 Lds Si,Graf { Carga la direcci≤n del grßfico }

 Add Si,4 { El grßfico en sφ comienza en [Graf+4] }

 Mov Ax,320

 Xor Dx,Dx

 Mul Y

 Add Ax,X

 Mov Di,Ax { Calcula la posici≤n de inicio }

 Mov Ax,0A000h

 Mov Es,Ax

 Mov Cx,Alto { El bucle se ejecutarß tantas veces como alto sea }

 Mov Dl,Mask

@Repite:

 Push Cx

 Mov Cx,Ancho

@Escribe:

 Lodsb

@Normal:

 Cmp Dl,0

 Jne @XOR

 Jmp @FinCase

@XOR:

 Cmp Dl,1

 Jne @OR

 Xor Al,byte ptr [Es:Di]

 Jmp @FinCase

@OR:

 Cmp Dl,2

 Jne @AND

 Or Al,byte ptr [Es:Di]

 Jmp @FinCase

@AND:

 Cmp Dl,3

 Jne @NOT

 And Al,byte ptr [Es:Di]

 Jmp @FinCase

@NOT:

 Not Al

 Jmp @FinCase

@FinCase:

 Stosb

 Loop @Escribe

 Pop Cx

 Mov Bx,320 { Salta a la siguiente lφnea }

 Sub Bx,Ancho

 Add Di,Bx

 Loop @Repite

 Pop Ds

End; { PROCEDURE PonSprite }


Procedure LeeSprite;Assembler;

{ Lee una regi≤n de la pantalla y la almacena en un buffer }

Var

 Ancho,Alto : Word;

Asm

 Push Ds

 Les Di,Graf

 Xor Ah,Ah

 Mov Ax,x2

 Sub Ax,x1

 Inc Ax

 Mov word ptr [Es:Di],Ax

 Mov Ancho,Ax

 Mov Ax,y2

 Sub Ax,y1

 Inc Ax

 Mov word ptr [Es:Di+2],Ax

 Mov Alto,Ax

 Add Di,4

 Dec Y1

 Dec X1

 Mov Ax,320

 Xor Dx,Dx

 Mul Y1

 Add Ax,X1

 Mov Si,Ax { Calcula la posici≤n de origen }

 Mov Ax,0A000h

 Mov Ds,Ax

 Mov Cx,Alto

@Repite:

 Push Cx

 Mov Cx,Ancho { Almacena cada lφnea }

 Rep Movsb

 Pop Cx

 Mov Bx,320 { Salta a la siguiente lφnea }

 Sub Bx,Ancho

 Add Si,Bx

 Loop @Repite

 Pop Ds

End; { PROCEDURE LeeSprite }

Procedure PonPunto;Assembler;

{ Escribe un punto de un color determinado }

Asm

 Dec X

 Dec Y

 Xor Dx,Dx

 Mov Ax,320

 Mul Y

 Add Ax,X

 Mov Di,Ax

 Mov Ax,0A000h

 Mov Es,Ax

 Mov Al,Color

 Mov Es:[Di],Al

End; { PROCEDURE PonPunto }

Procedure Escribe;

{ Usando la tabla que hay en la posici≤n $F000:$FA6E y que contiene

 los caracteres CGA se escribe un texto. }

Var

 Linea : Byte;

 Byt,

 Bit,Codigo: Byte;

 Caracter : String[1];

 Car,Xx,Yy : Integer;

 Segm,Ofss : Word;

Begin

 Xx:=x;

 Yy:=y;

 For Car := 0 to Length(Texto)-1 do

 Begin

 Caracter:=Copy(Texto,Car+1,1);

 Codigo:=Ord(Caracter[1]);

 { Si el carßcter es mayor de 127 no aparece en la tabla estßndar. Aparece

 en una tabla en cuya direcci≤n se encuentra el vector de interrupci≤n

 1Fh. }

 If Codigo<128 then

 Begin

 Segm:=$F000;

 Ofss:=$FA6E+Codigo*8;

 End

 Else

 Begin

 Segm:=Seg1F;

 Ofss:=Ofs1F+Codigo*8;

 End;

 { Escribe el carßcter. Escribe las 8 lφneas de barrido. }

 For Byt:=0 to 7 do

 Begin

 Linea:=Byte(Ptr(Segm,Ofss+Byt)^);

 Xx:=x+Car*8;

 Yy:=Y+Byt;

 { Cada lφnea de barrido se compone de 8 pixels }

 For Bit:=0 to 7 do

 Begin

 { No hay que escribir }

 If Linea < $7F then

 Xx:=Xx+1

 Else

 Begin

 { Escribe el punto }

 PonPunto(Xx,Yy,Color);

 Xx:=Xx+1;

 Linea:=Linea-$80;

 End;

 Linea:=Linea Shl 1;

 End;

 End;

 Yy:=Yy-7;

 End;

End; { PROCEDURE Escribe }


Begin

 Asm

 Mov Ah,35h

 Mov Al,1Fh

 Int 21h { Calcula la direcci≤n de la tabla de caracteres ASCII }

 Mov Seg1F,Es

 Mov Ofs1F,Bx

 End;

End.

Miguel Hernßndez Martos

Las Gabias (Granada)


GRAFICOS FRACTALES

La funci≤n de este truco es generar grßficos fractales, mßs en
concreto de los conjuntos de Julia. Si deseßis tener mßs informaci≤n
sobre este tipo de conjuntos os recomendamos leer el mencionado ½PC
Prßctico╗.

El programa es realmente sencillo, por lo que resulta fßcil modificar
algunos parßmetros para conseguir otros efectos y asφ comprender un
poco mßs este tipo de grßficos. Es fßcil modificar los colores, el
tama±o del grßfico en pantalla y la regi≤n a visualizar.

Program Fractal;

Uses Graph, Crt;

Const

 PixelH=150;

 PixelV=100;

 { Tama±o en pixels del grßfico en pantalla }

 xsup=-1.8;

 ysup=1.8;

 xinf=-1.8;

 yinf=1.8;

 {regi≤n del fractal a mostrar }

Var

 a,b,DeltaX,DeltaY,NewY2,x,y,x1,x2,y1,y2,SumaCuadrados:Real;

 cont:Byte;

 i,j,gd,gm,color:Integer;

Begin

 ClrScr;

 WriteLn ('Es necesario introducir el valor de un n·mero imaginario con
 notaci≤n x+yi');

 Write('Introduzca el valor de x=> ');

 ReadLn(a);

 Write('Introduzca el valor de y=> ');

 ReadLn(b);

 gm:=Detect;

 gd:=0;

 InitGraph(gd,gm,'');

 x1:=xsup;

 y1:=ysup;

 x2:=xinf;

 y2:=yinf;

 DeltaX:=(y1-x1)/PixelH;

 DeltaY:=(y2-x2)/PixelV;

 For i:= 1 To PixelH do

 Begin

 x1:=x1+DeltaX;

 NewY2:=y2;

 For j:=1 To PixelV do

 Begin

 NewY2:=NewY2-DeltaY;

 y:=NewY2;

 x:=x1;

 cont:=0;

 SumaCuadrados:=sqr(x)+sqr(y);

 While (Cont<50) And (SumaCuadrados<100) Do

 Begin

 x:=Sqr(x)-Sqr(y)+a;

 y:=2*x*b+b;

 SumaCuadrados:=sqr(x)+sqr(y);

 inc(cont);

 End;

{ En este bloque se asignan los colores a los puntos dependiendo de la
velocidad de escape del punto; se pueden modificar para jugar con el
grßfico }

 If SumaCuadrados>100 Then

 Begin

 If cont<3 Then color:=11

 Else If Cont<4 Then Color:=9

 Else If Cont<6 Then Color:=1

 Else If Cont<8 Then Color:=13

 Else If Cont<12 Then Color:=5

 Else If Cont<15 Then Color:=4

 Else If Cont<20 Then Color:=12

 Else If Cont<27 Then Color:=2

 Else If Cont<35 Then Color:=14

 Else If Cont<45 Then Color:=7

 Else Color:=8;

 PutPixel(i,j,color);

 End;

 End;

 End;

 ReadLn;

 CloseGraph;

End.

Para el correcto funcionamiento del programa deberemos poner el
driver BGI en el directorio en que se encuentre almacenado o
bien cambiar la lφnea:

InitGraph(gd,gm,'');

De forma que entre las comillas ponga el directorio donde se
encuentra el driver BGI que necesitamos usar.

Juan Carlos Romero

Trujillo (Cßceres)


SCROLL DE PELICULA

Seguro que mßs de una vez habΘis deseado a±adir en vuestros programas
alguna pantalla de presentaci≤n como las que aparecen en las pelφculas
de cine. Pues bien, ahora es posible gracias al siguiente programa,
con el que podemos conseguir un impresionante efecto de scroll en modo
texto con una gran suavidad.

Se pueden a±adir tantas lφneas de texto como se deseen, incluso hasta
llenar toda la pantalla: basta con poner tantos ½gotoxy (x,y); write
('Texto');╗ como sean necesarios. Los ½delay╗ sirven para ajustar la
velocidad: si va demasiado lento basta con disminuir su valor,
mientras que si funciona muy rßpido habrß que incrementarlo.

USES crt;

VAR

 b:word;

BEGIN

 ClrScr;

 Gotoxy(34,13);write('*** PC Actual ***');

 Gotoxy(33,14);write('Scroll de pelφcula');

 Gotoxy(1,24);

 REPEAT

 WHILE (Port[$3DA] AND 8)=0 DO ;

 Portw[$3D4] := $008;

 Writeln;

 Delay(15);

 FOR b:=0 TO $E DO

 BEGIN

 WHILE (Port[$3DA] AND 8)=0 DO ;

 Portw[$3D4]:=$108+B*256;

 Delay(15);

 END;

 UNTIL KeyPressed;

 Portw[$3D4]:=$08;

END.

Santos Herranz Domingo

Madrid



VUELO ESPACIAL

Seguro que uno de los salvapantallas mßs utilizados por los usuarios
habituales de Windows es el ½Starfield simulation╗, ya que combina muy
acertadamente los ingredientes de sencillez y dinamismo. Pues bien,
con esta rutina tambiΘn los usuarios del DOS podrßn disfrutar de ese
conocido vuelo espacial.

Las aplicaciones de esta utilidad pueden ser diversas. Por ejemplo,
quienes comienzan a programar juegos de arcade la pueden encontrar
·til como escenario en el que desarrollar la acci≤n. O quienes no
dispongan de un salvapantallas para DOS la pueden emplear como tal,
bien activßndola cuando se ausenten, bien modificßndola de modo que
quede residente (a tal fin, os recordamos que en nuestro n·mero de
enero del 93 premiamos un truco titulado ½Rutinas residentes╗, en el
que se indicaban los pasos a seguir).

La ½velocidad╗ de nuestro viaje dependerß de la potencia del ordenador
sobre el que lo ejecutemos, por lo que a los pasajeros que sufran del
denominado ½vΘrtigo espacial╗ les puede interesar incluir un Delay (n)
en cualquier punto del c≤digo, donde ½n╗ es un n·mero entero que
indica un retardo en milisegundos.

USES Graph, Crt;

TYPE

 Pointrec = RECORD

 sX, sY, ox, oy: LongInt;

 oapo, apo, c : Byte;

 END;

VAR

 Parr : Array[1..255] Of Pointrec;

 GD,GM,mx,my,I,cc,j,smx,smy : Integer;

 kl : LongInt;

 ch : Char;

 rx,ry,tx,ty : LongInt;

 starnum,decv : Byte;

BEGIN

 IF paramcount=0 THEN starnum:=120 ELSE val(paramstr(1),starnum,i);

 IF starnum<30 THEN starnum:=120;

 DetectGraph(GD,GM);

{la siguiente lφnea indica el path donde se sit·an los controladores
grßficos *.bgi dentro de nuestro disco duro}

 InitGraph(GD,GM,'d:\bp\bgi');

 mx:=getmaxx; my:=getmaxy; smx:=mx div 2; smy:=my div 2;

 decv:=starnum div 30;

 Randomize;

 FillChar(Parr,SizeOF(Parr),0);

 FOR i:=1 TO starnum DO WITH Parr[i] DO

 BEGIN

 sx:=(random(Succ(mx))-smx)*80; sy:=(random(Succ(my))-smy)*60;

 apo:=random(200)+decv;

 c:=Random(7)+1;

 ox:=sx; oy:=sy; oapo:=apo;

 END;

 REPEAT

 FOR i:=1 TO starnum DO WITH Parr[i] DO

 BEGIN

 oapo:=apo; ox:=sx; oy:=sy;

 dec(apo,decv);

 RX:=(sx div SUCC(apo))+smx;

 RY:=(sy div SUCC(apo))+smy;

 TX:=(ox div SUCC(oapo))+smx;

 TY:=(oy div SUCC(oapo))+smy;

 IF (RX>640) OR (RY>480) OR (RX<0) OR (RY<0) OR (APO<decv) THEN

 BEGIN

 sx:=(random(Succ(mx))-smx)*80; sy:=(random(Succ(my))-smy)*60;

 apo:=200+decv;

 RX:=(sx div SUCC(apo))+smx; RY:=(sy div SUCC(apo))+smy;

 END;

 IF apo>120 THEN cc:=C ELSE cc:=C+8;

 PutPixel(TX,TY,0); PutPixel(RX,RY,cc);

 IF OAPO<70 THEN PutPixel(TX+1,TY+1,0);

 IF APO<70 THEN PutPixel(RX+1,RY+1,cc);

 IF OAPO<60 THEN PutPixel(TX+1,TY,0);

 IF APO<60 THEN PutPixel(RX+1,RY,cc);

 IF OAPO<50 THEN PutPixel(TX,TY+1,0);

 IF APO<50 THEN PutPixel(RX,RY+1,cc);

 IF OAPO<40 THEN PutPixel(TX-1,TY-1,0);

 IF APO<40 THEN PutPixel(RX-1,RY-1,cc);

 IF OAPO<30 THEN PutPixel(TX+2,TY+2,0);

 IF APO<30 THEN PutPixel(RX+2,RY+2,cc);

 IF OAPO<20 THEN BEGIN

 PutPixel(TX+2,TY-1,0); PutPixel(TX-1,TY+2,0);

 END;

 IF APO<20 THEN BEGIN

 PutPixel(RX+2,RY-1,cc); PutPixel(RX-1,RY+2,cc);

 END;

 END;

 UNTIL KeyPressed;

 WHILE KeyPressed DO ch:= ReadKey;

 Closegraph;

END.

Antonio Delgado Garcφa

Madrid

Nota del Laboratorio: El programa funciona ejecutando ½stars╗ o
½stars n╗, donde ½n╗ es un parßmetro que indica el n·mero de estrellas
que aparecerßn en pantalla. Si se introduce sin parßmetro s≤lo
aparecerßn 120 estrellas. Este programa detecta la tarjeta grßfica y
se adapta a su resoluci≤n.